home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 February: Tool Chest / Apple Developer CD Series Tool Chest February 1996 (Apple Computer)(1996).iso / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / 2.01 sources / Interface Toolkit-2.01 / menu-editor.Lisp < prev   
Encoding:
Text File  |  1993-09-16  |  38.6 KB  |  1,011 lines  |  [TEXT/CCL2]
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;;  menu-editor.lisp
  3. ;;
  4. ;;
  5. ;;  ©1989-1991 Apple Computer, Inc
  6. ;;
  7. ;;  the menu editor portion of the interface designer
  8. ;;
  9.  
  10.  
  11.  
  12. ;;;;;;;;;;;;;;;;;
  13. ;;
  14. ;; Change history
  15. ;;
  16. ;; 04/28/93 mwp Release
  17. ;; 11/03/92 bill pseudo-edit-menu-dialog now looks like a windoid, not a :document window.
  18. ;; ------------- 2.0
  19. ;; 03/23/92 bill function-definition now quotes symbols.
  20. ;; 03/19/92 bill function-definition makes a 0-arg function if it can't find source
  21. ;; ------------- 2.0f3
  22. ;; 11/11/91 alice nuke nfunction
  23. ;; 11/06/91 bill *restore-lisp-functions* -> def-load-pointers
  24. ;; 07/26/91 bill make editing titles active
  25. ;; 01/15/91 bill (method object-source-code (apple-menu)) had leftover object-lisp
  26. ;; 08/03/90 bill :parent -> :class
  27. ;;
  28.  
  29.  
  30. ;;;;;;;;;;;;;;;;;
  31. ;;
  32. ;; packages and symbols and classes
  33. ;;
  34.  
  35. (in-package :interface-tools)
  36.  
  37. (defvar *menu-scrap* nil)
  38. (defparameter *menu-arrow-bitmap* nil)
  39.  
  40. (defclass menubar-editor (non-editable-dialog)
  41.   ((current-menu :initform nil :accessor menubar-editor-menu))
  42.   (:default-initargs
  43.    :window-type :document
  44.    :window-title "Menubar Editor"
  45.    :view-position #@(6 59)
  46.    :view-size #@(345 171)))
  47.  
  48. (defclass menu-editor (non-editable-dialog)
  49.     ((current-item :initform nil :accessor menu-editor-current-item)
  50.      (edited-menu :initform nil :initarg :menu :accessor menu-editor-edited-menu))
  51.     (:default-initargs
  52.      :view-position #@(186 60)
  53.      :window-type :document
  54.      :view-size #@(342 233)
  55.      :window-show nil))
  56.  
  57. (defclass editable-table (sequence-dialog-item)
  58.   ((my-text-editor :initform nil :accessor editable-table-text-editor)
  59.    (edit-text-offset :allocation :class :accessor edit-text-offset)))
  60.  
  61. (defclass menubar-editable-table (editable-table)
  62.   ((edit-text-offset :allocation :class :initform #@(2 1)))
  63.   (:default-initargs
  64.    :table-print-function #'(lambda (object stream)
  65.                              (format stream (menu-title object)))))
  66.  
  67. (defclass menu-editable-table (editable-table)
  68.   ((edit-text-offset :allocation :class :initform #@(12 1))))
  69.  
  70. (defclass table-text-edit (editable-text-dialog-item)
  71.   ((current-cell :initform nil :accessor table-text-edit-current-cell)
  72.    (my-table :initarg :table :initform nil :accessor table-text-edit-table)
  73.    (my-offset :initarg :offset :initform #@(2 1) :accessor table-text-edit-offset)
  74.    (full-size :initarg :full-size :accessor table-text-edit-full-size)
  75.    (small-size :initarg :small-size :accessor table-text-edit-small-size))
  76.   (:default-initargs
  77.    :draw-outline nil
  78.    :dialog-item-text ""
  79.    :allow-returns t
  80.    :view-position #@(0 0)
  81.    :view-nick-name :table-text-edit))
  82.  
  83. (defclass pseudo-edit-menu-dialog (windoid non-editable-dialog)
  84.   ()
  85.   (:default-initargs
  86.    :window-title "Edit"
  87.    :view-size #@(133 87)))  
  88.  
  89. (defclass add-menu-item-menu-item (menu-item)
  90.   ((my-class-choice :initarg :class-choice :initform nil :accessor add-menu-item-class-choice)))
  91.  
  92. (defvar *menubar-list* ())
  93. (defvar %current-menubar-editor nil)
  94.  
  95.  
  96. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  97. ;;
  98. ;;  patches for menubars, menus and menu-items
  99. ;;
  100.  
  101. (defmethod set-part-color :around ((menubar menubar) part new-color)
  102.   (declare (ignore new-color))
  103.   (call-next-method)
  104.   (when (eq part :default-menu-title)
  105.     (update-menubar-editor)))
  106.  
  107. (defmethod set-part-color :around ((menu menu) part new-color)
  108.   (declare (ignore part))
  109.   (call-next-method)
  110.   (let* ((editor %current-menubar-editor)
  111.          (pos (position menu (menubar))))
  112.     (when (and editor pos)
  113.       (set-part-color (view-named 'my-table editor)
  114.                       (make-point 0 pos)
  115.                       new-color))))
  116.  
  117. (defvar *menu-editor-hash* (make-hash-table :test 'eq :weak t))
  118.  
  119. (defun get-menu-editor (menu)
  120.   (gethash menu *menu-editor-hash*))
  121.  
  122. (defun (setf get-menu-editor) (editor menu)
  123.   (if editor
  124.     (setf (gethash menu *menu-editor-hash*) editor)
  125.     (remhash menu *menu-editor-hash*)))
  126.  
  127. ;;*** this is pessimal, but it works      
  128. (defmethod set-part-color :around ((menu-item menu-item) part new-color)
  129.   (call-next-method)
  130.   (let* ((owner (menu-item-owner menu-item))
  131.          (editor (and owner (get-menu-editor owner))))
  132.     (when (and editor
  133.                (or (eq part :item-title)
  134.                    (eq part :item-key)))
  135.       (let* ((pos (make-point 0
  136.                               (position menu-item (menu-items owner)))))
  137.         (when (eq part :item-title)
  138.           (set-part-color (view-named 'my-menu-table editor)  pos new-color))
  139.         (update-items-for-new-selection editor pos)))))
  140.  
  141. ;;;;;;;;;;;;;;;;
  142. ;;
  143. ;; global sets of menubars
  144. ;;
  145.  
  146. (defun init-menubar-list (&rest menubars)
  147.   (setq *menubar-list* (rplacd (last menubars) menubars)))
  148.  
  149. (defun make-spec-from-menubar ()
  150.   (cons (menu-items *apple-menu*)
  151.         (cdr (menubar))))
  152.  
  153. (progn
  154.   (init-menubar-list (make-spec-from-menubar))
  155.   nil)
  156.  
  157. (defun rotate-menubars ()
  158.   (update-list-from-menubar)
  159.   (setq *menubar-list* (cdr *menubar-list*))
  160.   (update-menubar-from-list))
  161.  
  162. (defun add-menubar ()
  163.   (push nil (cdr *menubar-list*))
  164.   (rotate-menubars))
  165.  
  166. (defun delete-menubar ()
  167.   (setq *menubar-list* (carless-circle *menubar-list*))
  168.   (update-menubar-from-list))
  169.  
  170. (defun carless-circle (c-list)
  171.    (let ((start c-list))
  172.      (until (eq (cdr c-list)
  173.                 start)
  174.        (setq c-list (cdr c-list)))
  175.      (setf (cdr c-list)
  176.            (cddr c-list))))
  177.  
  178. (defun update-menubar-from-list ()
  179.   (let* ((menubar-spec (car *menubar-list*))
  180.          (apple-items (car menubar-spec))
  181.          (rest-menus (cdr menubar-spec))
  182.          (a-menu *apple-menu*)
  183.          (*menubar-frozen* t))
  184.     (update-list-from-menubar)
  185.     (set-menubar nil)
  186.     (apply #'remove-menu-items a-menu (menu-items a-menu))
  187.     (apply #'add-menu-items a-menu apple-items)
  188.     (set-menubar rest-menus)
  189.     (update-menubar-editor)
  190.     (#_drawmenubar)))
  191.  
  192. (defun update-list-from-menubar ()
  193.   (setf (car *menubar-list*) (make-spec-from-menubar)))
  194.  
  195. (defun update-menubar-editor ()
  196.   (let ((the-win %current-menubar-editor))
  197.     (when the-win
  198.       (set-table-sequence (view-named 'my-table the-win) (menubar)))))
  199.  
  200. ;;;;;;;;;;;;;;;;;;;;;;;;;
  201. ;;
  202. ;; used for indicating a heirarchical menu
  203. ;;
  204.  
  205. (def-load-pointers init-menu-arrow-bitmap ()
  206.   (let ((pointer (#_NewPtr :errchk 36)))
  207.     (%put-ptr pointer (%inc-ptr pointer 14))      ;BaseAddr
  208.     (%put-word pointer 2 4)                        ;rowbytes
  209.     (%put-long pointer #@(0 0) 6)                  ;rectangle topleft
  210.     (%put-long pointer #@(16 11) 10)               ;rectangle bottomright
  211.     (%put-word  pointer #b1000000000000000 14)
  212.     (%put-word  pointer #b1100000000000000 16)
  213.     (%put-word  pointer #b1110000000000000 18)
  214.     (%put-word  pointer #b1111000000000000 20)
  215.     (%put-word  pointer #b1111100000000000 22)
  216.     (%put-word  pointer #b1111110000000000 24)
  217.     (%put-word  pointer #b1111100000000000 26)
  218.     (%put-word  pointer #b1111000000000000 28)
  219.     (%put-word  pointer #b1110000000000000 30)
  220.     (%put-word  pointer #b1100000000000000 32)
  221.     (%put-word  pointer #b1000000000000000 34)
  222.     (setq *menu-arrow-bitmap* pointer)))
  223.  
  224. ;;;;;;;;;;;;;;;;;
  225. ;;; *table-text-edit*
  226. ;;
  227. ;; this is the editable-text item which appears on top of a table
  228. ;; to give the illusion of editing an element in a table
  229.  
  230. (defmethod initialize-instance ((item table-text-edit) &key table)
  231.   (unless (typep table 'editable-table)
  232.     (error "A :table of type ~s must be passed to initialize-instance for ~s"
  233.            'editable-table 'table-text-edit))
  234.   (call-next-method)
  235.   (let ((size (view-size item)))
  236.     (setf (table-text-edit-full-size item) size)
  237.     (setf (table-text-edit-small-size item) (subtract-points size #@(23 0)))))
  238.  
  239. (defmethod view-draw-contents ((item table-text-edit))
  240.   (call-next-method)
  241.   (let* ((pos (view-position item))
  242.          (size (add-points pos (view-size item))))
  243.     (rlet ((rect :rect
  244.                  :topleft pos
  245.                  :bottomright size))
  246.       (#_InsetRect :ptr rect :long #@(-1 -1))
  247.       (#_FrameRect :ptr rect))))
  248.  
  249. (defmethod view-corners ((item table-text-edit))
  250.   (multiple-value-call #'inset-corners #@(-1 -1) (call-next-method)))
  251.  
  252. (defmethod select-all ((item table-text-edit))
  253.   (set-selection-range item 0 (buffer-size (fred-buffer item))))
  254.  
  255. (defmethod update-position ((item table-text-edit) &optional dont-set-current)
  256.   (let* ((table (table-text-edit-table item))
  257.          (table-bottom (point-v (add-points (view-position table) (view-size table))))
  258.          (cell (table-text-edit-current-cell item))
  259.          (cell-height (and cell (point-v (cell-size table))))
  260.          (position (and cell (cell-position table cell)))
  261.          (window (view-window table)))
  262.     (if (and position (<= (+ (point-v position) cell-height) table-bottom))
  263.       (let ((menu-item (cell-contents table cell)))
  264.         (dialog-item-enable item)
  265.         (set-view-size
  266.          item
  267.          (cond ((command-key menu-item)
  268.                 (table-text-edit-small-size item))
  269.                ((typep menu-item 'menu)
  270.                 (subtract-points (table-text-edit-full-size item) #@(16 0)))
  271.                (t (table-text-edit-full-size item))))
  272.         (set-view-position item (add-points (table-text-edit-offset item) position))
  273.         (set-view-container item window)
  274.         (unless dont-set-current
  275.           (set-current-key-handler window item)))
  276.       (progn
  277.         (set-view-container item nil)))))
  278.  
  279. ;***also take color?
  280. (defmethod set-link ((item table-text-edit) cell)
  281.   (setf (table-text-edit-current-cell item) cell)
  282.   (when cell
  283.     (let* (text color)
  284.       (let ((table (table-text-edit-table item)))
  285.         (setq text (get-cell-text table cell)
  286.               color (part-color table cell)))
  287.       (set-dialog-item-text item text)
  288.       (set-part-color item :text color)))
  289.   (let ((dialog (view-container (table-text-edit-table item))))
  290.     (unless cell
  291.       (update-items-for-new-selection dialog cell))
  292.     (update-position item)
  293.     (when cell
  294.       (select-all item))
  295.     (when cell
  296.       (update-items-for-new-selection dialog cell))))
  297.  
  298. (defmethod view-key-event-handler ((item table-text-edit) key)
  299.   (let* ((cell (table-text-edit-current-cell item)))
  300.     (when cell
  301.       (if (eq key #\return)
  302.         (return-key item)
  303.         (flet ((modcnt (item)
  304.                  (and (typep item 'fred-dialog-item)
  305.                       (buffer-modcnt (fred-buffer item)))))
  306.           (let* ((modcnt (modcnt item)))
  307.             (call-next-method)
  308.             (setf (view-get item 'update-cell)
  309.                   (or (null modcnt) (not (eql modcnt (modcnt item)))))))))))
  310.  
  311. (defmethod key-handler-idle ((item table-text-edit) &optional dialog)
  312.   (declare (ignore dialog))
  313.   (when (view-get item 'update-cell)
  314.     (setf (view-get item 'update-cell) nil)
  315.     (update-cell (table-text-edit-table item)
  316.                  (table-text-edit-current-cell item)
  317.                  (dialog-item-text item)))
  318.   (call-next-method))
  319.  
  320. (defmethod return-key ((item table-text-edit))
  321.   (let* ((cell (table-text-edit-current-cell item))
  322.          (text (dialog-item-text item))
  323.          (window (view-window item)))
  324.     (update-cell (table-text-edit-table item) cell text)
  325.     (set-link item nil)
  326.     (when window (window-update-event-handler window))))
  327.  
  328. (defmethod view-click-event-handler ((item table-text-edit) where)
  329.   (declare (ignore where))
  330.   (if (double-click-p)
  331.     (let* ((cell (table-text-edit-current-cell item)))
  332.       (and cell
  333.            (setq cell (cell-contents (table-text-edit-table item) cell))
  334.            (typep cell 'menu)
  335.            (progn (return-key item)
  336.                   (make-instance 'menu-editor :menu cell))))
  337.     (call-next-method)))
  338.  
  339.  
  340. ;;;;;;;;;;;;;;;;;;;;;;;
  341. ;;;
  342. ;;; editable-table
  343. ;;
  344. ;; a table whose contents can be edited
  345. ;;
  346. ;; used as a parent-class for menubar-editable-table and menu-editable-table
  347. ;; subclasses must define get-cell-text, and update-cell
  348.  
  349. (defmethod initialize-instance :after ((table editable-table) &key)
  350.   (let* ((edit-text-offset (edit-text-offset table)))
  351.     (setf (editable-table-text-editor table)
  352.           (make-instance 'table-text-edit
  353.                          :view-size (subtract-points
  354.                                      (cell-size table)
  355.                                      (subtract-points edit-text-offset
  356.                                                       #@(-1 1)))
  357.                          :offset edit-text-offset
  358.                          :table table))))
  359.  
  360. (defmethod view-click-event-handler ((table editable-table) where)
  361.   (let ((text-editor (editable-table-text-editor table))
  362.         (cell (point-to-cell table where))
  363.         (window (view-window table)))
  364.     (if cell
  365.       (set-link text-editor cell)
  366.       (progn
  367.         (call-next-method)
  368.         (update-position text-editor t)))
  369.     (when (view-container text-editor)
  370.       (view-focus-and-draw-contents text-editor)
  371.       (validate-view text-editor))
  372.     (window-update-event-handler window)))
  373.  
  374. (defmethod set-table-sequence ((table editable-table) new-sequence)
  375.   (let ((old-v (point-v (scroll-position table))))
  376.     (without-interrupts
  377.      (call-next-method)
  378.      (when (and (<= old-v (length new-sequence))
  379.                 (neq old-v (point-v (scroll-position table))))
  380.        (scroll-to-cell table 0 old-v))
  381.      (let ((text-editor (editable-table-text-editor table)))
  382.      (when text-editor
  383.        (set-link text-editor nil))))))
  384.  
  385. (defmethod set-part-color ((table editable-table) part new-color)
  386.   (let ((text-editor (editable-table-text-editor table)))
  387.     (when text-editor
  388.       (when (eq part (table-text-edit-current-cell text-editor))
  389.         (set-part-color text-editor :text new-color)))
  390.     (call-next-method)))
  391.  
  392. ;;;;;;;;;;;;;;;;;;;;;;;;;;;
  393. ;;;
  394. ;;; menubar-editable-table
  395. ;;
  396. ;; an editable table designed to display a menubar
  397. ;;
  398.  
  399. (defmethod get-cell-text ((table menubar-editable-table) cell)
  400.   (menu-title (cell-contents table cell)))
  401.  
  402. (defmethod update-cell ((table menubar-editable-table) cell text)
  403.   (set-menu-title (cell-contents table cell) text))
  404.  
  405. (defmethod set-table-sequence ((table menubar-editable-table) new-sequence)
  406.   (without-interrupts
  407.    (call-next-method)
  408.    (let ((default-color (part-color  *menubar* :default-menu-title)))
  409.      (do* ((menu (pop new-sequence) (pop new-sequence))
  410.            (cell #@(0 0) (add-points cell #@(0 1))))
  411.           ((not menu))
  412.        (set-part-color table
  413.                        cell
  414.                        (or (part-color (cell-contents table cell) :menu-title)
  415.                            default-color))))))
  416.  
  417.  
  418. ;;;;;;;;;;;;;;;;;;;;;;;;;;;
  419. ;;;
  420. ;;; menu-editable-table
  421. ;;
  422. ;; an editable table designed to display menus
  423. ;;
  424. (defmethod get-cell-text ((table menu-editable-table) cell)
  425.   (menu-item-title (cell-contents table cell)))
  426.  
  427. (defmethod update-cell ((table menu-editable-table) cell text)
  428.   (set-menu-item-title (cell-contents table cell) text))
  429.  
  430. (defmethod set-table-sequence ((table menu-editable-table) new-sequence)
  431.   (without-interrupts
  432.    (call-next-method)
  433.    (do* ((item (pop new-sequence) (pop new-sequence))
  434.          (cell #@(0 0) (add-points cell #@(0 1))))
  435.         ((not item))
  436.      (set-part-color table
  437.                      cell
  438.                      (part-color-with-default (cell-contents table cell) :menu-item-title)))))
  439.  
  440. (defmethod draw-cell-contents ((table menu-editable-table) cell &optional v)
  441.   (setq cell (make-point cell v))
  442.   (let* ((item (cell-contents table cell))
  443.          (cell-width (make-point (point-h (cell-size table)) 0))  ;should be hard-wired
  444.          (wptr (wptr table))
  445.          (init-pos (rref wptr :windowRecord.pnloc))
  446.          mark title key
  447.          mark-color title-color key-color)
  448.     (setq mark (menu-item-check-mark item)
  449.           title (menu-item-title item)
  450.           key (or (command-key item) (typep item 'menu)))
  451.     (when mark
  452.       (setq mark-color (part-color-with-default item :item-mark)))
  453.     (setq title-color (part-color-with-default item :item-title))
  454.     (when key
  455.       (setq key-color (part-color-with-default item :item-key)))
  456. ; (with-port wptr
  457.     (when mark
  458.       (with-fore-color mark-color
  459.         (#_drawchar :word (char-code mark))))
  460.     (#_moveto :long (add-points init-pos #@(10 0)))
  461.     (with-fore-color title-color
  462.       (with-pstrs ((title title))
  463.         (#_drawstring :ptr title)))
  464.     (when key
  465.       (setq cell-width (add-points cell-width init-pos))
  466.       (with-fore-color key-color
  467.         (if (eq key t)
  468.           (progn
  469.             (setq cell-width (subtract-points cell-width #@(12 10)))
  470.             (rlet ((rect :rect :topleft cell-width
  471.                          :bottomright (add-points cell-width #@(16 11))))
  472.               (#_CopyBits :ptr *menu-arrow-bitmap*
  473.                           :ptr (rref wptr windowRecord.portbits)
  474.                           :ptr (%inc-ptr *menu-arrow-bitmap* 6)
  475.                           :ptr rect
  476.                           :word 0
  477.                           :ptr (ccl::%null-ptr))))
  478.           (progn
  479.             (#_moveto :long (subtract-points cell-width #@(26 0)))
  480.             (#_drawchar :word (char-code #\commandmark))
  481.             (#_drawchar :word (char-code key))))))))
  482.  
  483. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  484. ;;
  485. ;; add-menu-item-menu-items
  486. ;;
  487.  
  488. (defmethod initialize-instance :after ((item add-menu-item-menu-item) &key)
  489.   (set-menu-item-title item (string-downcase (add-menu-item-class-choice item))))
  490.  
  491. (defmethod menu-item-action ((item add-menu-item-menu-item))
  492.   (let* ((*menu-scrap* (make-instance (add-menu-item-class-choice item)
  493.                                       :menu-item-title "Untitled")))
  494.     (declare (special *menu-scrap*))
  495.     (paste (front-window))))
  496.  
  497. (defvar *editable-menu-item-classes* ())
  498.  
  499. (defun add-editable-menu-item (class-or-name)
  500.   (let* ((class (if (symbolp class-or-name) 
  501.                   (find-class class-or-name)
  502.                   class-or-name))
  503.          (class-name (class-name class))
  504.          (proto (class-prototype class)))
  505.     (unless (or (typep proto 'menu-item)
  506.                 (typep proto 'menu))
  507.       (error "~s does not name a subclass of menu or menu-item" class-or-name))
  508.     (let ((classes *editable-menu-item-classes*))
  509.       (unless (memq class-name classes)
  510.         (setq *editable-menu-item-classes*
  511.               (nconc classes (list class-name)))))))
  512.  
  513. (add-editable-menu-item 'menu-item)
  514. (add-editable-menu-item 'menu)
  515. (add-editable-menu-item 'window-menu-item)
  516.  
  517.  
  518. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  519. ;;
  520. ;; menubar editor
  521. ;;
  522.  
  523. (defmethod update-items-for-new-selection ((editor menubar-editor) cell)
  524.   (setf (menubar-editor-menu editor)
  525.         (if cell
  526.           (cell-contents (view-named 'my-table editor) cell))))
  527.  
  528. (defmethod initialize-instance :after ((editor menubar-editor) &key menubar)
  529.   (add-subviews
  530.    editor
  531.    (make-dialog-item 'menubar-editable-table
  532.                      #@(10 5) #@(150 133) "" nil
  533.                      :cell-size #@(134 16)
  534.                      :table-hscrollp nil
  535.                      :table-vscrollp t
  536.                      :table-sequence (or menubar (menubar))
  537.                      :view-nick-name 'my-table)
  538.    (make-dialog-item 'button-dialog-item
  539.                      #@(9 145) #@(153 16) "Print Menubar Source"
  540.                      #'(lambda (item)
  541.                          (declare (ignore item))
  542.                          (let* ((*print-length* nil)
  543.                                 (*print-level* nil)
  544.                                 (*print-array* t)
  545.                                 (*print-pretty* t)
  546.                                 (win (make-instance 'fred-window))
  547.                                 (menus (menubar)))
  548.                            (with-cursor *watch-cursor*
  549.                              (format win "~s"
  550.                                      `(progn ,(object-source-code (pop menus))
  551.                                              (set-menubar (list ,@(mapcar
  552.                                                                    #'(lambda (menu)
  553.                                                                        (object-source-code menu))
  554.                                                                    menus)))))
  555.                              (fred-update win)))))
  556.    (make-dialog-item 'button-dialog-item
  557.                      #@(178 11) #@(153 16) "Add Menu"
  558.                      #'(lambda (item)
  559.                          (insert-menu (make-instance 'menu :menu-title "Untitled")
  560.                                       (menubar-editor-menu (view-container item)))
  561.                          (update-menubar-editor)))
  562.    (make-dialog-item 'title-box-dialog-item
  563.                      #@(173 45) #@(164 117) "Menubar Operations" nil)
  564.    (make-dialog-item 'button-dialog-item
  565.                      #@(177 60) #@(153 16) "Rotate Menubars"
  566.                      #'(lambda (item)
  567.                          (declare (ignore item))
  568.                          (rotate-menubars)))
  569.    (make-dialog-item 'button-dialog-item
  570.                      #@(177 82) #@(153 16) "Add New Menubar"
  571.                      #'(lambda (item)
  572.                          (declare (ignore item))
  573.                          (add-menubar)))
  574.    (make-dialog-item 'button-dialog-item
  575.                      #@(177 104) #@(153 16) "Delete Menubar"
  576.                      #'(lambda (item)
  577.                          (declare (ignore item))
  578.                          (delete-menubar)))
  579.    (make-dialog-item 'color-part-pop-up
  580.                      #@(177 130) #@(147 21) "Menubar Colors" nil
  581.                      :colored-object *menubar*
  582.                      :part-codes '(:default-menu-title
  583.                                    :default-menu-background
  584.                                    :default-item-title
  585.                                    :menubar))))
  586.  
  587. (defmethod window-close :before ((editor menubar-editor))
  588.   (map-windows #'(lambda (w) (window-close w)) :class 'pseudo-edit-menu-dialog)
  589.   (setq %current-menubar-editor nil))
  590.  
  591. (defun edit-menubar ()
  592.   (let* ((old-ed %current-menubar-editor)
  593.          (old-pseudo (car (windows :class 'pseudo-edit-menu-dialog
  594.                                    :include-invisibles t
  595.                                    :include-windoids t))))
  596.     (if old-ed
  597.         (window-select old-ed)
  598.         (setq %current-menubar-editor
  599.               (setq old-ed (make-instance 'menubar-editor :menubar (menubar)))))
  600.     (if old-pseudo
  601.       (window-select old-pseudo)
  602.       (let ((old-ed-pos (view-position old-ed))
  603.             (old-ed-width (point-h (view-size old-ed))))
  604.           (setq old-pseudo
  605.                 (make-instance 'pseudo-edit-menu-dialog
  606.                                :view-position
  607.                                (add-points old-ed-pos
  608.                                            (make-point (+ 10 old-ed-width)
  609.                                                        0))))))))
  610.  
  611. (defun insert-menu (menu after)
  612.   (let ((menus (memq after (menubar)))
  613.         (*menubar-frozen* t))
  614.     (declare (special *menubar-frozen*))
  615.     (dolist (1menu menus)
  616.       (menu-deinstall 1menu))
  617.     (menu-install menu)
  618.     (dolist (1menu menus)
  619.       (menu-install 1menu))
  620.     (#_drawmenubar)))
  621.  
  622. (defmethod cut ((editor menubar-editor))
  623.   (let* ((menu (menubar-editor-menu editor)))
  624.     (when menu
  625.       (setq *menu-scrap* menu)
  626.       (menu-deinstall menu)
  627.       (update-menubar-editor))))
  628.  
  629. (defmethod copy ((editor menubar-editor))
  630.   (let* ((menu (menubar-editor-menu editor)))
  631.     (when menu
  632.       (setq *menu-scrap* (copy-instance menu)))))
  633.  
  634. (defmethod paste ((editor menubar-editor))
  635.   (let* ((new-menu *menu-scrap*)
  636.          (before-menu (menubar-editor-menu editor)))
  637.     (when (typep new-menu 'menu)
  638.       (insert-menu new-menu before-menu)
  639.       (update-menubar-editor))))
  640.  
  641. (defmethod clear ((editor menubar-editor))
  642.   (let* ((menu (menubar-editor-menu editor)))
  643.     (when menu
  644.       (menu-deinstall menu)
  645.       (update-menubar-editor))))
  646.  
  647. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  648. ;;
  649. ;; menu-editor
  650. ;;
  651.  
  652.  
  653. (defmethod initialize-instance :after ((editor menu-editor) &key menu)
  654.   (setf (get-menu-editor menu) editor)
  655.   (set-window-title editor (concatenate 'string "\"" (menu-title menu) "\" Menu"))
  656.   (add-subviews
  657.    editor
  658.    (make-dialog-item 'menu-editable-table
  659.                      #@(8 25) #@(155 179) "" nil
  660.                      :table-sequence (menu-items menu)
  661.                      :cell-size #@(139 16)
  662.                      :table-hscrollp nil
  663.                      :table-vscrollp t
  664.                      :view-nick-name 'my-menu-table)
  665.    (make-dialog-item 'button-dialog-item
  666.                      #@(7 209) #@(158 16) "Print Menu Source"
  667.                      #'(lambda (item)
  668.                          (let ((container (view-container item)))
  669.                            (let* ((*print-length* nil)
  670.                                   (*print-level* nil)
  671.                                   (*print-array* t)
  672.                                   (win (make-instance 'fred-window)))
  673.                              (pprint (object-source-code
  674.                                       (menu-editor-edited-menu container))
  675.                                      win)))))
  676.    (make-dialog-item 'pop-up-menu
  677.                      #@(165 26) #@(160 20) "" nil
  678.                      :item-display "Add Menu Item"
  679.                      :menu-items
  680.                      (mapcar #'(lambda (class-sym)
  681.                                  (make-instance 'add-menu-item-menu-item
  682.                                                 :class-choice class-sym))
  683.                              *editable-menu-item-classes*))
  684.    (make-dialog-item 'check-box-dialog-item
  685.                      #@(172 89) #@(76 16) "Disabled"
  686.                      #'(lambda (item)
  687.                          (let* ((container (view-container item))
  688.                                 (current-item (menu-editor-current-item container)))
  689.                            (when current-item
  690.                              (if (check-box-checked-p item)
  691.                                (menu-item-disable current-item)
  692.                                (menu-item-enable current-item)))))
  693.                      :view-nick-name 'my-disabled-check-box)
  694.    (make-dialog-item 'one-char-box
  695.                      #@(277 70) #@(18 16) ""
  696.                      #'(lambda (item)
  697.                          (let* ((container (view-container item))
  698.                                 (current-item (menu-editor-current-item container))
  699.                                 (string (dialog-item-text item))
  700.                                 (new-char (if (> (length string) 0)
  701.                                             (char string 0)
  702.                                             nil)))
  703.                            (when current-item
  704.                              (set-command-key current-item new-char)
  705.                              (invalidate-selected-table-cell container :right))))
  706.                      :view-nick-name 'my-char-box
  707.                      :allow-returns nil)
  708.    (make-dialog-item 'check-box-dialog-item
  709.                      #@(172 109) #@(100 16) "Check Mark"
  710.                      #'(lambda (item)
  711.                          (let* ((container (view-container item))
  712.                                 (current-item (menu-editor-current-item container)))
  713.                            (when current-item
  714.                              (set-menu-item-check-mark 
  715.                               current-item (check-box-checked-p item))
  716.                              (invalidate-selected-table-cell container :left))))
  717.                      :view-nick-name 'my-checked-check-box)
  718.    (make-dialog-item 'static-text-dialog-item
  719.                      #@(8 5) #@(89 16) "Menu Items:" nil)
  720.    (make-dialog-item 'static-text-dialog-item
  721.                      #@(173 69) #@(100 16) "Command Key:" nil
  722.                      :view-nick-name 'my-command-item-title)
  723.    (make-dialog-item 'button-dialog-item
  724.                      #@(173 132) #@(160 16) "Menu Item Action"
  725.                      #'(lambda (item)
  726.                          (let ((container (view-container item)))
  727.                            (new-action-from-dialog (menu-editor-current-item container))))
  728.                      :view-nick-name 'my-action-button)
  729.    (make-dialog-item 'title-box-dialog-item
  730.                      #@(173 162) #@(162 63) "Colors" nil)
  731.    (make-dialog-item 'color-part-pop-up
  732.                      #@(176 171) #@(155 19) "Menu Colors" nil
  733.                      :colored-object menu
  734.                      :part-codes '(:menu-title
  735.                                    :menu-background
  736.                                    :default-item-title))
  737.    (make-dialog-item 'color-part-pop-up
  738.                      #@(176 196) #@(155 20) "Menu Item Colors" nil
  739.                      :view-nick-name 'my-item-color-menu
  740.                      :colored-object nil
  741.                      :part-codes '(:item-title
  742.                                    :item-key
  743.                                    :item-mark)))
  744.   (update-items-for-new-selection editor nil)
  745.   (window-show editor))
  746.  
  747. (defmethod invalidate-selected-table-cell ((window menu-editor) &optional part)
  748.   (let* ((table (view-named 'my-menu-table window))
  749.          (editor (editable-table-text-editor table)))
  750.     (when (view-container editor)
  751.       (let* ((pos (view-position editor))
  752.              (size (view-size editor))
  753.              (left (point-h (view-position table)))
  754.              (right (+ left (point-h (view-size table))))
  755.              (top (point-v pos))
  756.              (bottom (+ top (point-v size))))
  757.         (cond ((null part))
  758.               ((eq part :left)
  759.                (setq right (- (point-h pos) 1)))
  760.               ((eq part :right)
  761.                (setq left (+ (point-h pos) (point-h size) 2))))
  762.         (if (or (null part) (eq part :left))
  763.           (update-position editor t))
  764.         (invalidate-corners window (make-point left top) (make-point right bottom))))))
  765.  
  766. (defmethod window-close :before ((editor menu-editor))
  767.   (return-key editor)
  768.   (setf (get-menu-editor (menu-editor-edited-menu editor)) nil))
  769.  
  770. (defmethod return-key ((editor menu-editor))
  771.   (let ((text-edit (editable-table-text-editor (view-named 'my-menu-table editor))))
  772.     (when (and text-edit (view-container text-edit))
  773.       (return-key text-edit))))
  774.  
  775. (defmethod update-items-for-new-selection ((editor menu-editor) item)
  776.   (let ((disabled-check-box (view-named 'my-disabled-check-box editor))
  777.         (char-box (view-named 'my-char-box editor))
  778.         (action-button (view-named 'my-action-button editor))
  779.         (item-color-menu (view-named 'my-item-color-menu editor))
  780.         (checked-box (view-named 'my-checked-check-box editor))
  781.         (command-item-title (view-named 'my-command-item-title editor)))
  782.     (if item
  783.       (let* (enabled com-char com-char-color check-mark)
  784.         (setq item (cell-contents (view-named 'my-menu-table editor) item))
  785.         (setf (menu-editor-current-item editor) item)
  786.         (setq enabled (menu-item-enabled-p item)
  787.               com-char (command-key item)
  788.               com-char-color (part-color-with-default item :item-key)
  789.               check-mark (menu-item-check-mark item))
  790.         (dialog-item-enable disabled-check-box)
  791.         (if enabled
  792.           (check-box-uncheck disabled-check-box)
  793.           (check-box-check disabled-check-box))
  794.         (dialog-item-enable char-box)
  795.         (set-dialog-item-text char-box (if com-char
  796.                                          (string com-char)
  797.                                          ""))
  798.         (set-part-color char-box :text com-char-color)
  799.         (dialog-item-enable command-item-title)
  800.         (if (typep item 'menu)
  801.           (progn (dialog-item-disable action-button)
  802.                  (dialog-item-disable checked-box))
  803.           (progn (dialog-item-enable action-button)
  804.                  (dialog-item-enable checked-box)))
  805.         (dialog-item-enable item-color-menu)
  806.         (set-colored-object item-color-menu item)
  807.         (if check-mark
  808.           (check-box-check checked-box)
  809.           (check-box-uncheck checked-box)))
  810.       (progn
  811.         (setf (menu-editor-current-item editor) nil)
  812.         (check-box-uncheck disabled-check-box)
  813.         (dialog-item-disable disabled-check-box)
  814.         (set-dialog-item-text char-box "")
  815.         (dialog-item-disable char-box)
  816.         (check-box-uncheck checked-box)
  817.         (dialog-item-disable checked-box)
  818.         (dialog-item-disable command-item-title)
  819.         (dialog-item-disable action-button)
  820.         (dialog-item-disable item-color-menu)))))
  821.  
  822. (defmethod new-action-from-dialog ((item menu-item))
  823.   (let ((*save-definitions* t))
  824.     (setf (menu-item-action-function item)
  825.            (eval (read-from-string
  826.                   (get-text-from-user
  827.                    "Please enter text for the menu-item-action:"
  828.                    (menu-item-action-source item)))))))
  829.  
  830. (defmethod menu-item-action-source ((item menu-item) &aux old-fun)
  831.   (let* ((*print-pretty* t))
  832.     (format nil
  833.             "(function  ~a)"
  834.             (let ((f (menu-item-action-function item)))
  835.               (if f
  836.                 (or (and (setq old-fun (uncompile-function f))
  837.                          (format nil "~s" old-fun))
  838.                     "(lambda ()
  839. ;The previous source code for the action could not be found.
  840. ;Perhaps the code for the menu was loaded from a fasl file,
  841. ;or was compiled with *SAVE-DEFINITIONS* bound to nil
  842. )")
  843.                 "(lambda ()
  844. ;Enter action source code here.
  845. )")))))
  846.  
  847. (defmethod new-action-from-dialog ((item window-menu-item))
  848.   (let* ((old-action-symbol (menu-item-action-function item)))
  849.     (setf (menu-item-action-function item)
  850.           (read-from-string
  851.            (get-string-from-user "Please enter the name of a window function to be called when this menu-item is selected."
  852.                                  :initial-string (format nil "~s" old-action-symbol)
  853.                                  :size #@(350 90))
  854.            nil))))
  855.  
  856.  
  857. (defmethod cut ((editor menu-editor))
  858.   (let* ((item (menu-editor-current-item editor))
  859.          (menu (menu-editor-edited-menu editor)))
  860.     (if item
  861.         (progn
  862.           (setq *menu-scrap* item)
  863.           (remove-menu-items menu item)
  864.           (set-table-sequence (view-named 'my-menu-table editor) (menu-items menu)))
  865.         (progn
  866.           (ed-beep)
  867.           (message-dialog "There is no selected menu-item to cut.")))))
  868.  
  869. (defmethod copy ((editor menu-editor))
  870.   (let* ((item (menu-editor-current-item editor)))
  871.     (if item
  872.         (setq *menu-scrap* (copy-instance item))
  873.         (progn
  874.           (ed-beep)
  875.           (message-dialog "There is no selected menu-item to copy.")))))
  876.  
  877. (defmethod paste ((editor menu-editor))
  878.   (let* ((item *menu-scrap*)
  879.          (menu (menu-editor-edited-menu editor))
  880.          (before-item (menu-editor-current-item editor)))
  881.     (cond ((not item)
  882.            (ed-beep)
  883.            (message-dialog "No menu-item has been copied or cut."))
  884.           (t
  885.            ;(print-db 1)
  886.            (insert-menu-item menu item before-item)
  887.            ;(print-db 2)
  888.            (set-table-sequence (view-named 'my-menu-table editor) (menu-items menu))
  889.            ;(print-db 3)
  890.            (setq *menu-scrap* (copy-instance item))
  891.            ;(print-db 4)
  892.            ))))
  893.  
  894.  
  895. (defmethod insert-menu-item ((menu menu) item before-what)
  896.   (let ((m-items (memq before-what (menu-items menu))))
  897.     (apply #'remove-menu-items menu  m-items)
  898.     (apply #'add-menu-items menu item m-items)))
  899.  
  900. (defmethod clear ((editor menu-editor))
  901.   (let* ((item (menu-editor-current-item editor))
  902.          (menu (menu-editor-edited-menu editor)))
  903.     (if item
  904.         (progn
  905.           (remove-menu-items menu item)
  906.           (set-table-sequence (view-named 'my-menu-table editor) (menu-items menu)))
  907.         (progn
  908.           (ed-beep)
  909.           (message-dialog "There is no selected menu-item to clear.")))))
  910.  
  911.  
  912. ;;;;;;;;;;;;;;;;;;;
  913. ;;
  914. ;; cut/copy/paste/clear dialog
  915. ;;
  916.  
  917. (defmethod initialize-instance :after ((dialog pseudo-edit-menu-dialog) &key)
  918.   (add-subviews
  919.    dialog
  920.    (make-dialog-item 'button-dialog-item
  921.                      #@(4 4)  #@(125 16) "Cut"
  922.                      #'(lambda (item)
  923.                          (declare (ignore item))
  924.                          (cut (front-window))))
  925.    (make-dialog-item 'button-dialog-item
  926.                      #@(4 25) #@(125 16) "Copy"
  927.                      #'(lambda (item)
  928.                          (declare (ignore item))
  929.                          (copy (front-window))))
  930.    (make-dialog-item 'button-dialog-item
  931.                      #@(4 45) #@(125 16) "Paste"
  932.                      #'(lambda (item)
  933.                          (declare (ignore item))
  934.                          (paste (front-window))))
  935.    (make-dialog-item 'button-dialog-item
  936.                      #@(4 66) #@(125 16) "Clear"
  937.                      #'(lambda (item)
  938.                          (declare (ignore item))
  939.                          (clear (front-window))))))
  940.  
  941.  
  942.  
  943. ;;;;;;;;;;;;;;;;;;;;
  944. ;;
  945. ;; source code printing for menus and menu-items
  946. ;;
  947.  
  948. (defmethod object-source-code ((menu menu))
  949.   (let* ((source (and (next-method-p) (call-next-method))) ;pop-up-menus use dialog-item version
  950.          (colors (part-color-list menu))
  951.          (items `(list ,@(mapcar #'(lambda (item)
  952.                                      (object-source-code item))
  953.                                  (menu-items menu)))))
  954.     (if source
  955.         (nconc source
  956.                `(:menu-items ,items
  957.                 ,@(if colors
  958.                       `(:menu-colors ',colors))))
  959.         `(make-instance  ',(class-name (class-of menu))
  960.                          :menu-title ,(menu-title menu)
  961.                          ,@(if colors
  962.                              `(:menu-colors ',colors))
  963.                          :menu-items ,items))))
  964.  
  965. (defmethod object-source-code ((menu apple-menu))
  966.   `(let ((apple-menu *apple-menu*))
  967.      (apply #'remove-menu-items apple-menu (menu-items apple-menu))
  968.      (apply #'add-menu-items
  969.             apple-menu
  970.             (list ,@(mapcar #'(lambda (item)
  971.                                 (object-source-code item))
  972.                             (menu-items menu))))))
  973.  
  974. (defun function-definition (f)
  975.   (cond ((null f) nil)
  976.         ((symbolp f) `',f)
  977.         ((functionp f)
  978.          (let ((name (function-name f)))
  979.            (if (and (symbolp name) (fboundp name) (eq f (symbol-function name)))
  980.              `',name
  981.              (let ((def (uncompile-function f)))
  982.                (if def
  983.                  `(function ,def)
  984.                  '(function (lambda () "Can't find definition")))))))))
  985.  
  986. (defmethod object-source-code ((item menu-item) &aux value)
  987.   `(make-instance ',(class-name (class-of item))
  988.                   :menu-item-title ,(menu-item-title item)
  989.                   ,@(if (setq value (part-color-list item))
  990.                       `(:menu-item-colors ',value))
  991.                   ,@(if (setq value (function-definition (menu-item-action-function item)))
  992.                       `(:menu-item-action ,value))
  993.                   ,@(if (menu-item-enabled-p item)
  994.                       ()
  995.                       `(:disabled t))
  996.                   ,@(if (setq value (command-key item))
  997.                       `(:command-key ,value)
  998.                       ())
  999.                   ,@(if (neq (setq value (menu-item-style item)) :plain)
  1000.                       `(:menu-item-style ',value)
  1001.                       ())
  1002.                   ,@(if (setq value (menu-item-check-mark item))
  1003.                       `(:menu-item-checked ,value)
  1004.                       ())))
  1005.  
  1006. (defmethod object-source-code ((item window-menu-item))
  1007.   (let* ((source (call-next-method))
  1008.          (f (function-definition (menu-item-action-function item))))
  1009.     (remf source :menu-item-action)
  1010.     (nconc source `(:menu-item-action ,f))))
  1011.